PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/mee/vbdao/visdata/snapgrid.frm

Visual Basic Form | 1994-10-06 | 19.2 KB | 639 lines

VERSION 2.00
Begin Form fGridFrmSS
   BackColor       =   &H00C0C0C0&
   ClientHeight    =   3105
   ClientLeft      =   930
   ClientTop       =   3585
   ClientWidth     =   6690
   Height          =   3510
   Icon            =   0
   Left            =   870
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3096
   ScaleMode       =   0  'User
   ScaleWidth      =   6708
   Tag             =   "Dynaset"
   Top             =   3240
   Width           =   6810
   Begin Grid cGrid
      FixedCols       =   0
      FixedRows       =   0
      Height          =   2412
      Left            =   0
      TabIndex        =   0
      Top             =   480
      Width           =   6732
   End
   Begin PictureBox ViewButtons
      BackColor       =   &H00C0C0C0&
      BorderStyle     =   0  'None
      Height          =   375
      Left            =   0
      ScaleHeight     =   372
      ScaleMode       =   0  'User
      ScaleWidth      =   5171.606
      TabIndex        =   1
      Top             =   24
      Width           =   5175
      Begin CommandButton SortButton
         Caption         =   "&Sort"
         Height          =   372
         Left            =   3720
         TabIndex        =   9
         Top             =   0
         Width           =   612
      End
      Begin CommandButton FilterButton
         Caption         =   "Fil&ter"
         Height          =   372
         Left            =   3120
         TabIndex        =   8
         Top             =   0
         Width           =   612
      End
      Begin CommandButton RefreshButton
         Caption         =   "&Redo"
         Height          =   372
         Left            =   2520
         TabIndex        =   7
         Top             =   0
         Width           =   612
      End
      Begin CommandButton CloseButton
         Cancel          =   -1  'True
         Caption         =   "&Close"
         Height          =   372
         Left            =   4320
         TabIndex        =   6
         Top             =   0
         Width           =   612
      End
      Begin CommandButton MoreButton
         Caption         =   "&More"
         Height          =   372
         Left            =   1320
         TabIndex        =   5
         Top             =   0
         Width           =   612
      End
      Begin CommandButton NextButton
         Caption         =   "&Next"
         Height          =   372
         Left            =   120
         TabIndex        =   4
         Top             =   0
         Width           =   612
      End
      Begin CommandButton FirstButton
         Caption         =   "&First"
         Height          =   372
         Left            =   720
         TabIndex        =   3
         Top             =   0
         Width           =   612
      End
      Begin CommandButton FindButton
         Caption         =   "F&ind"
         Height          =   372
         Left            =   1920
         TabIndex        =   2
         Top             =   0
         Width           =   612
      End
   End
Option Explicit
'form variables
Dim FDS As Snapshot        'current form's snapshot
Dim FDynSt As String       'dynaset open string
Dim FTblName As String     'form dynaset table name
Dim FCurrentRow As Long    'current row in dynaset
Dim FGridRow As Integer    'current grid row
Dim FNotFound As Integer   'find not found flag
Dim FFindForm As New fFind 'find form
Dim FNumbRows As Long      'total number of rows in table
Dim FDynaString As String  'dynaset open string
Sub cGrid_DblClick ()
  Dim r As Integer       'return from execute sql
  Dim fn As String       'field name
  Dim bm As String
  Dim c As Integer
  On Error GoTo ZoomErr
  r = cGrid.Row
  cGrid.Row = 0
  'get field name
  fn = cGrid.Text
  cGrid.Row = r
  'only allow memo fields for browsing
  If FDS(fn).Type <> FT_MEMO Then
    Exit Sub
  End If
  'make sure it's a string or memo field
  If FDS(fn).Type <> FT_BINARY Then
     gstZoomData = cGrid.Text
     fZoom.caption = fn
     fZoom.Top = VDMDI.Top + Top + 1200
     fZoom.Left = VDMDI.Left + Left + 250
     If FDS(fn).Type <> FT_MEMO Then
       fZoom.cData = gstZoomData
       fZoom.Height = 1125
     Else
       fZoom.cMemo = gstZoomData
       fZoom.cMemo.Visible = True
       fZoom.cData.Visible = False
       fZoom.Height = 2205
     End If
     fZoom.CloseZoomButton.Visible = True
     fZoom.Show MODAL
  End If
  GoTo ZoomEnd
ZoomErr:
  ShowError
  Resume ZoomEnd
ZoomEnd:
End Sub
Sub cGrid_KeyUp (KeyCode As Integer, Shift As Integer)
  'zoom on F4 key press
  If KeyCode = &H73 Then   'F4
    cGrid_DblClick
  End If
End Sub
Sub CloseButton_Click ()
  Unload Me
End Sub
Sub FilterButton_Click ()
  On Error GoTo FilterErr
  Dim ds1 As Snapshot, ds2 As Snapshot
  Dim FilterStr As String
  Dim numbrows As Long    'local number of rows
  Set ds1 = FDS            'save the dynaset
  FilterStr = InputBox("Enter Filter Expression:")
  If Len(FilterStr) = 0 Then Exit Sub
  FDS.Filter = FilterStr
  Set ds2 = FDS.CreateSnapshot()            'establish the filter
  Set FDS = ds2            'assign back to original dynaset object
  'everything must be okay so redisplay form on 1st record
  FNumbRows = GetNumbRecsSS(FDS)          'query numb of recs
   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     caption = "SnapShot: " & FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48
     ResetMouse Me
     Unload Me
     Exit Sub
   ElseIf FNumbRows > gwMaxGridRows Then
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " rows]"
   End If
  If LoadGridSS(cGrid, FDS, FDynSt, numbrows, 0) = False Then
    Unload Me
    Exit Sub
  End If
  GoTo FilterEnd
FilterErr:
  ShowError
  Set FDS = ds1            're-assign back to original
  Resume FilterEnd
FilterEnd:
End Sub
Sub FindButton_Click ()
   Dim i As Integer, r As Integer, c As Integer
   On Error GoTo FindErr
   'load the column names into the find form
   'the 1st time it is loaded
   If FFindForm.cFieldList.ListCount = 0 Then
     FFindForm.cFieldList.Clear
     r = cGrid.Row
     c = cGrid.Col
     cGrid.Row = 0
     cGrid.Col = 0
     For i = 1 To cGrid.Cols - 1
       cGrid.Col = cGrid.Col + 1
       FFindForm.cFieldList.AddItem cGrid.Text
     Next
     cGrid.Row = r
     cGrid.Col = c
   End If
FindStart:       'used to loop around on not found
   'reset the flags
   gfFindFailed = False
   gfFromTableView = True
   MsgBar "Enter Search Parameters", False
   FFindForm.Show MODAL
   MsgBar "Searching for record", True
   If gfFindFailed = True Then Exit Sub
   FNotFound = False
   SetHourglass Me
   'search for the record
   cGrid.SetFocus        'start at the top
   SendKeys "^{Home}"
   cGrid.Col = 1
   cGrid.Row = 0
   'move the right column
   While cGrid.Text <> UCase(gstFindField)
     If cGrid.Col = cGrid.Cols Then 'reached max col
     Else
       cGrid.Col = cGrid.Col + 1
       SendKeys "{Right}"
     End If
   Wend
   cGrid.Row = 1
   While cGrid.Row < cGrid.Rows - 1
       If gfFindMatch = False Then
         Select Case gstFindOp
           Case "="
             If UCase(cGrid.Text) = UCase(gstFindExpr) Then GoTo AfterWhile
           Case "<>"
             If UCase(cGrid.Text) <> UCase(gstFindExpr) Then GoTo AfterWhile
           Case ">="
             If UCase(cGrid.Text) >= UCase(gstFindExpr) Then GoTo AfterWhile
           Case "<="
             If UCase(cGrid.Text) <= UCase(gstFindExpr) Then GoTo AfterWhile
           Case ">"
             If UCase(cGrid.Text) > UCase(gstFindExpr) Then GoTo AfterWhile
           Case "<"
             If UCase(cGrid.Text) < UCase(gstFindExpr) Then GoTo AfterWhile
           Case "Like"
             If UCase(cGrid.Text) Like UCase(gstFindExpr) Then GoTo AfterWhile
         End Select
       Else
         Select Case gstFindOp
           Case "="
             If cGrid.Text = gstFindExpr Then GoTo AfterWhile
           Case "<>"
             If cGrid.Text <> gstFindExpr Then GoTo AfterWhile
           Case ">="
             If cGrid.Text >= gstFindExpr Then GoTo AfterWhile
           Case "<="
             If cGrid.Text <= gstFindExpr Then GoTo AfterWhile
           Case ">"
             If cGrid.Text > gstFindExpr Then GoTo AfterWhile
           Case "<"
             If cGrid.Text < gstFindExpr Then GoTo AfterWhile
           Case "Like"
             If cGrid.Text Like gstFindExpr Then GoTo AfterWhile
         End Select
       End If
     cGrid.Row = cGrid.Row + 1
     SendKeys "{Down}"
   Wend
   FNotFound = True       'didn't find it
AfterWhile:
   ResetMouse Me
   'show the first record
   If FNotFound Then
     Beep
     MsgBox "Record Not Found", 48
     GoTo FindStart
   End If
   DoEvents
   cGrid.SelStartRow = cGrid.Row
   cGrid.SelStartCol = 1
   cGrid.SelEndRow = cGrid.Row
   cGrid.SelEndCol = FDS.Fields.Count
   GoTo FindEnd
FindErr:
   ResetMouse Me
   ShowError
   Resume FindEnd
FindEnd:
   MsgBar NULL_STR, False
End Sub
Sub FirstButton_Click ()
   Dim numbrows As Long         'number of rows
   On Error GoTo GoFirstError
   SetHourglass Me
   MsgBar "Going to first record", True
   cGrid.SetFocus
   cGrid.Row = 1
   cGrid.Col = 0
   'get current starting row in grid
   If cGrid.Text <> "1" Then
     FDS.Close
     Set FDS = gCurrentDB.CreateSnapshot(FDS.Name)
     FNumbRows = GetNumbRecsSS(FDS)
     If FNumbRows > gwMaxGridRows Then
       numbrows = gwMaxGridRows
       FCurrentRow = numbrows
     Else
       numbrows = FNumbRows
     End If
     If LoadGridSS(cGrid, FDS, FDynSt, numbrows, 0) = False Then
       Unload Me
       Exit Sub
     End If
  End If
  cGrid.Col = 1
  SendKeys "{Home}"
  GoTo GoFirstEnd
GoFirstError:
  ShowError
  Resume GoFirstEnd
GoFirstEnd:
  ResetMouse Me
  MsgBar NULL_STR, False
End Sub
Sub Form_Load ()
   Dim t As TableDef       'local table structure
   Dim sp As Integer       'starting point of table name
   Dim ep As Integer       'ending point of table name
   Dim wh As String        'where clause
   Dim i As Integer, j As Integer
   Dim fn As String        'field name
   Dim rc As Integer       'record count
   Dim numbrows As Long    'local number of rows
   Dim qd As QueryDef      'querydef for parameterized query
   Dim p_query As Integer  'param query flag
   Dim p_val As String     'param value
   Dim Start1, Finish1, Start2, Finish2
   On Error GoTo DynasetErr
   SetHourglass Me
   MsgBar "Opening Snapshot", True
   'assign the temp string with the select statement
   'if it is not empty, otherwise, use the table list name
   If gfFromSQL = True Then
     If Len(gstDynaString) = 0 Then
       FDynSt = fSQL.cSQLStatement
     Else
       FDynSt = gstDynaString
     End If
   Else
     FDynSt = fTables.cTableList
   End If
   'check for parameters
   If InStr(FDynSt, "PARAM1") > 0 Or InStr(gstDynaString, "PARAM1") > 0 Then
     'figure out if it is a saved querydef
     If Mid(UCase(FDynSt), 1, 7) = "SELECT " Then
       Set qd = gCurrentDB.CreateQueryDef("temp_qd", FDynSt)
       p_query = 1
     Else
       Set qd = gCurrentDB.OpenQueryDef(fTables.cTableList)
       p_query = 2
     End If
     'get the parameter value(s)
     For i = 1 To 4
       p_val = ""
       p_val = InputBox("Enter the value for parameter " & i)
       Select Case i
         Case 1
           qd!PARAM1 = p_val
         Case 2
           qd!PARAM2 = p_val
         Case 3
           qd!PARAM3 = p_val
         Case 4
           qd!PARAM4 = p_val
       End Select
       If InStr(FDynSt, "PARAM" & i + 1) = 0 And InStr(gstDynaString, "PARAM" & i + 1) = 0 Then Exit For
     Next
   End If
   'attemp to open the dynaset
   Start1 = TimeGetTime()
   If UCase(FDynSt) = "LISTTABLES" Then
     Set FDS = gCurrentDB.ListTables()
   Else
     If gfFromSQL = True Then
       If VDMDI.cPassThru.Visible = True And VDMDI.cPassThru = 1 Then
         Set FDS = gCurrentDB.CreateSnapshot(FDynSt, VBDA_SQLPASSTHROUGH)
       Else
         Set FDS = gCurrentDB.CreateSnapshot(FDynSt)
       End If
     Else
       If p_query = 0 Then
         If VDMDI.cPassThru.Visible = True And VDMDI.cPassThru = 1 Then
           FDynSt = "select * from " & StripOwner(FDynSt)
           Set FDS = gCurrentDB.CreateSnapshot(FDynSt, VBDA_SQLPASSTHROUGH)
         Else
           Set FDS = gCurrentDB.CreateSnapshot(FDynSt)
         End If
       Else
         Set FDS = qd.CreateSnapshot()
         qd.Close
         If p_query = 1 Then gCurrentDB.DeleteQueryDef "temp_qd"
       End If
'       Set FDS = gCurrentDB.CreateSnapshot(FDynSt)
     End If
   End If
   Finish1 = TimeGetTime()
   Start2 = TimeGetTime()
   'parse off table name to store in global gstTblName
   wh = NULL_STR
   sp = InStr(1, UCase(FDynSt), "FROM")
   If sp > 0 Then
     'must be a "select from" statement
     sp = sp + 5
     For ep = sp To Len(FDynSt)
       'search for a space or the end of FDynSt
       If Mid$(FDynSt, ep, 1) = " " Then
         'get where clause if there is one
         wh = Mid$(FDynSt, sp, Len(FDynSt) - sp + 1)
         Exit For
       End If
     Next
     FTblName = UCase(Mid$(FDynSt, sp, ep - sp))
     If Len(wh) = 0 Then wh = FTblName
   Else
     'must be a table name only
     FTblName = UCase(FDynSt)
     wh = FTblName
   End If
   FDynaString = wh
   'show the first record
   FNumbRows = GetNumbRecsSS(FDS)          'query numb of recs
   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     caption = "SnapShot: " & FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48
     ResetMouse Me
     Unload Me
     Exit Sub
   ElseIf FNumbRows > gwMaxGridRows Then
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " rows]"
   End If
   If LoadGridSS(cGrid, FDS, FDynSt, numbrows, 0) = False Then
     Unload Me
     Exit Sub
   End If
   Height = 3800
   Width = 5300
   Left = 1000
   Top = 1000
   Finish2 = TimeGetTime()
   If VDMDI.PrefShowPerf.Checked Then
     Me.Show
     MsgBox FNumbRows & " rows found in " & (Finish1 - Start1) / 1000 & " seconds!" & Chr(13) & Chr(10) & (Finish2 - Start2) / 1000 & " seconds to Load Grid!", 48
   End If
   GoTo OkayEnd
DynasetErr:
   If p_query = 1 Then
     gCurrentDB.DeleteQueryDef "temp_qd"
   End If
   ShowError
   ResetMouse Me
   MsgBar NULL_STR, False
   Unload Me
   Exit Sub
   Resume OkayEnd
OkayEnd:
   ResetMouse Me
   MsgBar NULL_STR, False
End Sub
Sub Form_Resize ()
  On Error Resume Next
  'resize grid to window
  If WindowState <> 1 Then   'not minimized
    cGrid.Height = Height - 900
    cGrid.Width = Width - 100
  End If
End Sub
Sub Form_Unload (Cancel As Integer)
  On Error Resume Next
  'unload the find form
  Unload FFindForm
  'close the associated dynaset
  FDS.Close
  MsgBar NULL_STR, False
End Sub
Sub MoreButton_Click ()
  Dim ret As Integer   'return value from loadgrid
  On Error Resume Next
  MsgBar "Getting more records", True
  If FDS.EOF <> True Then
    SetHourglass Me
    ret = LoadGridSS(cGrid, FDS, FDynSt, gwMaxGridRows, FCurrentRow)
    If ret = False Then
      'failed so bail out of form
      FDS.Close
      Unload Me
    End If
    'set new current row
    FCurrentRow = FCurrentRow + ret
    ResetMouse Me
  End If
  MsgBar NULL_STR, False
End Sub
Sub NextButton_Click ()
   Dim c As Integer      'current column
   On Error GoTo GoNextError
   c = cGrid.Col
   cGrid.Col = 0
   If Len(cGrid.Text) = 0 Then
     Beep
   ElseIf cGrid.Row = gwMaxGridRows Then
     MoreButton_Click
   Else
     cGrid.SetFocus
     SendKeys "{Down}"
   End If
   cGrid.Col = c
   GoTo GoNextEnd
GoNextError:
   ShowError
   Resume GoNextEnd
GoNextEnd:
End Sub
'needed for multi-user situations so
'new records can be viewed imediately
Sub RefreshButton_Click ()
   Dim numbrows As Long
   On Error GoTo RefreshError
   MsgBar "Reopening Dynaset", True
   SetHourglass Me
   Set FDS = gCurrentDB.CreateSnapshot(FDS.Name)
   FNumbRows = GetNumbRecsSS(FDS)
   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     caption = "SnapShot: " & FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48
     ResetMouse Me
     Unload Me
     Exit Sub
   ElseIf FNumbRows > gwMaxGridRows Then
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " rows]"
   End If
   If LoadGridSS(cGrid, FDS, FDynSt, numbrows, 0) = False Then
     Unload Me
     Exit Sub
   End If
  GoTo RefreshEnd
RefreshError:
  ShowError
  Resume RefreshEnd
RefreshEnd:
  ResetMouse Me
  MsgBar NULL_STR, False
End Sub
Sub SortButton_Click ()
  On Error GoTo SortErr
  Dim ds1 As Snapshot, ds2 As Snapshot
  Dim SortStr As String
  Dim numbrows As Long    'local number of rows
  Set ds1 = FDS            'save the dynaset
  SortStr = InputBox("Enter Sort Column:")
  If Len(SortStr) = 0 Then Exit Sub
  FDS.Sort = SortStr
  Set ds2 = FDS.CreateSnapshot()            'establish the Sort
  Set FDS = ds2            'assign back to original dynaset object
  'everything must be okay so redisplay form on 1st record
  FNumbRows = GetNumbRecsSS(FDS)          'query numb of recs
   If FNumbRows = -1 Then
     'error occurred but go on anyway
     'because row count is non-critical
     caption = "SnapShot: " & FTblName
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   ElseIf FNumbRows = 0 Then
     Beep
     MsgBox "No Records found!", 48
     ResetMouse Me
     Unload Me
     Exit Sub
   ElseIf FNumbRows > gwMaxGridRows Then
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " total rows]"
     numbrows = gwMaxGridRows
     FCurrentRow = numbrows
   Else
     numbrows = FNumbRows
     caption = "SnapShot: " & FTblName & " [" & CStr(FNumbRows) & " rows]"
   End If
  If LoadGridSS(cGrid, FDS, FDynSt, numbrows, 0) = False Then
    Unload Me
    Exit Sub
  End If
  GoTo SortEnd
SortErr:
  ShowError
  Set FDS = ds1            're-assign back to original
  Resume SortEnd
SortEnd:
End Sub